home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD7501772000.psc / Version 1.0 / ColourSelect.ctl < prev    next >
Encoding:
Text File  |  2000-07-07  |  6.3 KB  |  242 lines
  1. VERSION 5.00
  2. Begin VB.UserControl asxColourSelect 
  3.    ClientHeight    =   375
  4.    ClientLeft      =   0
  5.    ClientTop       =   0
  6.    ClientWidth     =   1230
  7.    ScaleHeight     =   25
  8.    ScaleMode       =   3  'Pixel
  9.    ScaleWidth      =   82
  10.    ToolboxBitmap   =   "ColourSelect.ctx":0000
  11. End
  12. Attribute VB_Name = "asxColourSelect"
  13. Attribute VB_GlobalNameSpace = False
  14. Attribute VB_Creatable = True
  15. Attribute VB_PredeclaredId = False
  16. Attribute VB_Exposed = False
  17.  
  18. '-----------------------------------------'
  19. '            Ariad Development Components '
  20. '-----------------------------------------'
  21. '                ColourSelect UserControl '
  22. '                             Version 1.0 '
  23. '-----------------------------------------'
  24. 'Copyright ⌐ 1999 by Ariad Software. All Rights Reserved.
  25.  
  26. 'Created        : 06/10/1999
  27. 'Completed      : 06/10/1999
  28. 'Last Updated   :
  29.  
  30.  
  31. Option Explicit
  32. DefInt A-Z
  33.  
  34. Private Type RECT
  35.  Left       As Long
  36.  Top        As Long
  37.  Right      As Long
  38.  Bottom     As Long
  39. End Type
  40.  
  41. Private Type TCHOOSECOLOR
  42.  lStructSize        As Long
  43.  hWndOwner          As Long
  44.  hInstance          As Long
  45.  rgbResult          As Long
  46.  lpCustColors       As Long
  47.  Flags              As Long
  48.  lCustData          As Long
  49.  lpfnHook           As Long
  50.  lpTemplateName     As Long
  51. End Type
  52.  
  53. Private Declare Function ChooseColor Lib "COMDLG32.DLL" Alias "ChooseColorA" (Color As TCHOOSECOLOR) As Long
  54. Private Declare Function DrawFocusRect& Lib "user32" (ByVal hDC As Long, lpRect As RECT)
  55. Private Declare Function DrawFrameControl Lib "user32" (ByVal hDC&, lpRect As RECT, ByVal un1 As Long, ByVal un2 As Long) As Boolean
  56. Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long
  57.  
  58. Private InFocus As Boolean
  59. Private IsPushed As Boolean
  60.  
  61. Private pColour As OLE_COLOR
  62.  
  63. Public Event Change(Color As OLE_COLOR)
  64. Private Function SelectColor(DefColor As Long, Optional ShowExpDlg As Boolean = 0, Optional InitCustomColours As Boolean = -1) As Long
  65.  Dim I
  66.  Dim C As Long
  67.  Dim CC As TCHOOSECOLOR
  68.  Dim CT$
  69.  Dim CustomColors(16) As Long
  70.  'Initialise Custom Colours
  71.  If InitCustomColours Then
  72.   For I = 0 To 15
  73.    CT$ = GetSetting$("Ariad Non-ADL User Settings", "CustomColours", CStr(I))
  74.    CustomColors(I) = IIf(Len(CT$), Val(CT$), QBColor(15))
  75.   Next
  76.  End If
  77.  'Show Dialog
  78.  With CC
  79.   .rgbResult = DefColor
  80.   .hWndOwner = hWnd
  81.   .lpCustColors = VarPtr(CustomColors(0))
  82.   .Flags = &H101
  83.   If ShowExpDlg Then .Flags = .Flags Or &H2
  84.   .lStructSize = Len(CC)
  85.   C = ChooseColor(CC)
  86.   If C Then
  87.    SelectColor = .rgbResult
  88.   Else
  89.    SelectColor = -1
  90.   End If
  91.  End With
  92. End Function
  93.  
  94. '------------------------------------------------------
  95. 'Name        : Colour
  96. 'Created     : 06/10/1999 19:41
  97. '------------------------------------------------------
  98. 'Author      : Richard James Moss
  99. 'Organisation: Ariad Software
  100. '------------------------------------------------------
  101. 'Description : Returns/sets the colour of the control.
  102. '------------------------------------------------------
  103. 'Returns     : Returns an OLE_COLOR Variable
  104. '------------------------------------------------------
  105. 'Updates     :
  106. '
  107. '------------------------------------------------------
  108. '              Ariad Procedure Builder Add-In 1.00.0027
  109. Public Property Get Colour() As OLE_COLOR
  110.  Colour = pColour
  111. End Property '(Public) Property Get Colour () As OLE_COLOR
  112.  
  113. Property Let Colour(ByVal Colour As OLE_COLOR)
  114.  pColour = Colour
  115.  PropertyChanged "Colour"
  116.  Refresh
  117. End Property ' Property Let Colour
  118.  
  119. '--------------------------------------------------------
  120. 'Name        : Refresh
  121. 'Created     : 06/10/1999 19:38
  122. '--------------------------------------------------------
  123. 'Author      : Richard James Moss
  124. 'Organisation: Ariad Software
  125. '--------------------------------------------------------
  126. 'Description : Forces a complete repaint of the control.
  127. '--------------------------------------------------------
  128. 'Updates     :
  129. '
  130. '--------------------------------------------------------
  131. '                Ariad Procedure Builder Add-In 1.00.0027
  132. Public Sub Refresh()
  133.  Dim Flags As Long
  134.  Dim R As RECT
  135.  Dim Z
  136.  Const FR = 3
  137.  Const CB = 5
  138.  Z = Abs(IsPushed)
  139.  Flags = 16
  140.  If IsPushed Then Flags = Flags Or 512
  141.  Line (-1, -1)-(ScaleWidth + 1, ScaleHeight + 1), vbButtonFace, BF
  142.  'border
  143.  R.Right = ScaleWidth
  144.  R.Bottom = ScaleHeight
  145.  DrawFrameControl hDC, R, 4, Flags
  146.  'colour
  147.  Line (CB + Z, CB + Z)-(ScaleWidth + Z - (CB + 1), ScaleHeight + Z - (CB + 1)), pColour, BF
  148.  Line (CB + Z, CB + Z)-(ScaleWidth + Z - (CB + 1), ScaleHeight + Z - (CB + 1)), vbWindowText, B
  149.  'focus
  150.  If InFocus Then
  151.   With R
  152.    .Left = FR + Z
  153.    .Top = FR + Z
  154.    .Bottom = ScaleHeight - (FR - Z)
  155.    .Right = ScaleWidth - (FR - Z)
  156.   End With
  157.   DrawFocusRect hDC, R
  158.  End If
  159. End Sub '(Public) Sub Refresh ()
  160.  
  161.  
  162. Private Sub UserControl_Click()
  163.  Dim C As Long, D As Long
  164.  OleTranslateColor pColour, 0, D
  165.  C = SelectColor(D)
  166.  If C <> -1 Then
  167.   Colour = C
  168.   RaiseEvent Change(C)
  169.  End If
  170. End Sub
  171.  
  172. Private Sub UserControl_GotFocus()
  173.  InFocus = -1
  174.  Refresh
  175. End Sub
  176.  
  177. Private Sub UserControl_Initialize()
  178.  AutoRedraw = -1
  179. End Sub
  180.  
  181.  
  182. Private Sub UserControl_InitProperties()
  183.  pColour = vbWhite
  184.  Refresh
  185. End Sub
  186.  
  187.  
  188. Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
  189.  If KeyCode = 32 Then
  190.   IsPushed = -1
  191.   Refresh
  192.  End If
  193. End Sub
  194.  
  195. Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
  196.  If KeyCode = 32 Then
  197.   IsPushed = 0
  198.   Refresh
  199.   UserControl_Click
  200.  End If
  201. End Sub
  202.  
  203.  
  204. Private Sub UserControl_LostFocus()
  205.  InFocus = 0
  206.  Refresh
  207. End Sub
  208.  
  209. Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  210.  InFocus = -1
  211.  IsPushed = -1
  212.  Refresh
  213. End Sub
  214.  
  215.  
  216. Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  217.  IsPushed = 0
  218.  Refresh
  219. End Sub
  220.  
  221.  
  222. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  223.  With PropBag
  224.   pColour = .ReadProperty("Colour", vbWhite)
  225.  End With
  226.  Refresh
  227. End Sub
  228.  
  229. Private Sub UserControl_Resize()
  230.  Refresh
  231. End Sub
  232.  
  233.  
  234. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  235.  With PropBag
  236.   .WriteProperty "Colour", pColour, vbWhite
  237.  End With
  238.  Refresh
  239. End Sub
  240.  
  241.  
  242.